home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 001 / pibt40s1.arc / DOCOMPUS.MOD < prev    next >
Text File  |  1987-04-30  |  40KB  |  1,273 lines
  1. (*----------------------------------------------------------------------*)
  2. (*    Do_CompuServe_B_Transfer --- Do Compuserve B Protocol transfer    *)
  3. (*----------------------------------------------------------------------*)
  4.  
  5. FUNCTION CompuServe_B_Transfer : BOOLEAN;
  6.  
  7. (*----------------------------------------------------------------------*)
  8. (*                                                                      *)
  9. (*     Routine:  CompuServe_B_Transfer                                  *)
  10. (*                                                                      *)
  11. (*     Purpose:  Executes CompuServe B protocol transfers               *)
  12. (*                                                                      *)
  13. (*     Calling Sequence:                                                *)
  14. (*                                                                      *)
  15. (*        OK := CompuServe_B_Transfer : BOOLEAN;                        *)
  16. (*                                                                      *)
  17. (*           OK   --- set TRUE if transfer went OK                      *)
  18. (*                                                                      *)
  19. (*     Calls:  None                                                     *)
  20. (*                                                                      *)
  21. (*     Called by:  Emulate_VT52                                         *)
  22. (*                 Emulate_ANSI                                         *)
  23. (*                                                                      *)
  24. (*     Remarks:                                                         *)
  25. (*                                                                      *)
  26. (*        This code is taken from some prepared by Jim Nutt.            *)
  27. (*                                                                      *)
  28. (*----------------------------------------------------------------------*)
  29.  
  30. CONST
  31.    Xmt_Size     = 511;
  32.    Rcv_Size     = 512;
  33.    Max_Errors   =  10;
  34.  
  35.                    (* Sender Actions *)
  36.  
  37.    S_Send_packet  = 0;
  38.    S_Get_DLE      = 1;
  39.    S_Get_num      = 2;
  40.    S_Get_seq      = 3;
  41.    S_Get_data     = 4;
  42.    S_Get_CheckSum = 5;
  43.    S_Timed_Out    = 6;
  44.    S_Send_NAK     = 7;
  45.  
  46.                    (* Receiver Actions *)
  47.  
  48.    R_Get_DLE      = 0;
  49.    R_Get_b        = 1;
  50.    R_Get_seq      = 2;
  51.    R_Get_data     = 3;
  52.    R_Get_CheckSum = 4;
  53.    R_Send_NAK     = 5;
  54.    R_Send_ACK     = 6;
  55.  
  56.                    (* Other Constants *)
  57.  
  58.    xmt_col = 50;
  59.    rcv_col = 36;
  60.    xon     = 17;
  61.    xoff    = 19;
  62.    dle     = 16;
  63.    etx     = 03;
  64.    nak     = 21;
  65.    ENQ     = 05;
  66.    wack    = 59;
  67.  
  68.    Err_Mess_Line = 5               (* Line for status report *);
  69.  
  70. TYPE
  71.    BufferType = ARRAY[0..520] OF BYTE;
  72.  
  73. VAR
  74.    Timer      : INTEGER;
  75.    R_Size     : INTEGER            (* size of receiver buffer *);
  76.    CheckSum   : INTEGER;
  77.    Seq_Num    : INTEGER;
  78.    Ch         : INTEGER;           (* current character *)
  79.  
  80.    Xoff_Flag  : BOOLEAN;
  81.    Masked     : BOOLEAN;           (* TRUE if ctrl character was 'Masked' *)
  82.  
  83.    S_Buffer   : BufferType;
  84.    R_Buffer   : BufferType;
  85.    FileName   : AnyStr             (* PathName *);
  86.    i          : INTEGER;
  87.    n          : INTEGER;
  88.    Dummy      : BOOLEAN;
  89.  
  90.    Comp_Title    : AnyStr;
  91.    Total_Blocks  : INTEGER        (* Blocks processed so far *);
  92.    Total_Packets : INTEGER        (* Packets thus far        *);
  93.    Total_Errors  : INTEGER        (* Errors thus far         *);
  94.    Total_Bytes   : REAL           (* Bytes thus far          *);
  95.    TFile_Size    : REAL           (* Size of file to send    *);
  96.  
  97.    Halt_Transfer : BOOLEAN        (* Keypressed to halt transfer *);
  98.    Receiving_File: BOOLEAN        (* TRUE if receiving file      *);
  99.  
  100.    Starting_Time : REAL           (* Start time of transfer      *);
  101.    Ending_Time   : REAL           (* End time of transfer        *);
  102.    Total_Time    : REAL           (* Total transfer time         *);
  103.    Reset_Port    : BOOLEAN        (* TRUE if port needs reset    *);
  104.  
  105. LABEL
  106.    Error_Exit;
  107.  
  108. (*----------------------------------------------------------------------*)
  109. (*  Initialize_Transfer_Display --- Initialize transfer display window  *)
  110. (*----------------------------------------------------------------------*)
  111.  
  112. PROCEDURE Initialize_Transfer_Display;
  113.  
  114. BEGIN (* Initialize_Transfer_Display *)
  115.  
  116.    Draw_Menu_Frame( 5, 10, 75, 16, Menu_Frame_Color, Menu_Title_Color,
  117.                     Menu_Text_Color, Comp_Title );
  118.  
  119.    TextColor( Menu_Text_Color_2 );
  120.  
  121.    GoToXY( 1 , 1 );
  122.    WRITE('Packets transferred: ');
  123.  
  124.    GoToXY( 1 , 2 );
  125.    WRITE('Bytes transferred:   ');
  126.  
  127.    GoToXY( 1 , 3 );
  128.    WRITE('Total errors:        ');
  129.  
  130.    GoToXY( 1 , 4 );
  131.  
  132.    IF ( NOT Receiving_File ) THEN
  133.       WRITE('Bytes to send:       ');
  134.  
  135.    ClrEol;
  136.  
  137.    GoToXY( 1 , Err_Mess_Line );
  138.    WRITE('Last status message: ');
  139.  
  140.    CursorOff;
  141.  
  142.    TextColor( Menu_Text_Color );
  143.  
  144.    Write_Log( Comp_Title, FALSE, FALSE );
  145.  
  146. END   (* Initialize_Transfer_Display *);
  147.  
  148. (*----------------------------------------------------------------------*)
  149. (*            Update_B_Display --- Update blocks received display       *)
  150. (*----------------------------------------------------------------------*)
  151.  
  152. PROCEDURE Update_B_Display;
  153.  
  154. BEGIN (* Update_B_Display *)
  155.  
  156.    IF Display_Status THEN
  157.       BEGIN
  158.  
  159.          TextColor( Menu_Text_Color );
  160.  
  161.          GoToXY( 22 , 1 );
  162.          WRITE( Total_Packets:8 );
  163.          ClrEol;
  164.  
  165.          GoToXY( 22 , 2 );
  166.          WRITE( Total_Bytes:8:0 );
  167.          ClrEol;
  168.  
  169.          GoToXY( 22 , 3 );
  170.          WRITE( Total_Errors:8 );
  171.          ClrEol;
  172.  
  173.          IF ( NOT Receiving_File ) THEN
  174.             BEGIN
  175.                GoToXY( 22 , 4 );
  176.                WRITE( TFile_Size:8:0 );
  177.                ClrEol;
  178.             END;
  179.  
  180.       END;
  181.  
  182. END   (* Update_B_Display *);
  183.  
  184. (*----------------------------------------------------------------------*)
  185. (*        Flip_Display_Status --- turn status display on/off            *)
  186. (*----------------------------------------------------------------------*)
  187.  
  188. PROCEDURE Flip_Display_Status;
  189.  
  190. BEGIN (* Flip_Display_Status *)
  191.  
  192.    CASE Display_Status OF
  193.  
  194.       TRUE:   BEGIN
  195.                                    (* Indicate no display   *)
  196.  
  197.                  Display_Status := FALSE;
  198.  
  199.                                    (* Remove display window  *)
  200.  
  201.                  Restore_Screen( Saved_Screen );
  202.  
  203.                  Reset_Global_Colors;
  204.  
  205.                                    (* Restore cursor *)
  206.                  CursorOn;
  207.  
  208.               END;
  209.  
  210.       FALSE:  BEGIN
  211.                                    (* Indicate display will be done *)
  212.  
  213.                  Display_Status := TRUE;
  214.  
  215.                                    (* Save screen image *)
  216.  
  217.                  Save_Partial_Screen( Saved_Screen, 5, 10, 75, 16 );
  218.  
  219.                                    (* Initialize display window     *)
  220.  
  221.                  Initialize_Transfer_Display;
  222.  
  223.               END;
  224.  
  225.    END (* CASE *);
  226.  
  227. END   (* Flip_Display_Status *);
  228.  
  229. (*----------------------------------------------------------------------*)
  230. (*        Display_Message --- Display message in transfer window        *)
  231. (*----------------------------------------------------------------------*)
  232.  
  233. PROCEDURE Display_Message( Message: AnyStr );
  234.  
  235. BEGIN (* Display_Message *)
  236.  
  237.    IF ( NOT Display_Status ) THEN
  238.       Flip_Display_Status;
  239.  
  240.    TextColor( Menu_Text_Color );
  241.  
  242.    GoToXY( 22 , Err_Mess_Line );
  243.    WRITE( Message );
  244.    ClrEol;
  245.  
  246.    Write_Log( Message, TRUE, FALSE );
  247.  
  248. END   (* Display_Message *);
  249.  
  250. (*----------------------------------------------------------------------*)
  251. (*     Display_Message_With_Number --- Display message with a number    *)
  252. (*----------------------------------------------------------------------*)
  253.  
  254. PROCEDURE Display_Message_With_Number( Message: AnyStr; Number: INTEGER );
  255.  
  256. VAR
  257.    S: STRING[10];
  258.  
  259. BEGIN (* Display_Message_With_Number *)
  260.  
  261.    IF ( NOT Display_Status ) THEN
  262.       Flip_Display_Status;
  263.  
  264.    TextColor( Menu_Text_Color );
  265.  
  266.    GoToXY( 22 , Err_Mess_Line );
  267.    WRITE( Message , Number );
  268.    ClrEol;
  269.  
  270.    STR( Number , S );
  271.  
  272.    Write_Log( Message + S, TRUE, FALSE );
  273.  
  274. END   (* Display_Message_With_Number *);
  275.  
  276. (*----------------------------------------------------------------------*)
  277. (*               Check_Keyboard --- Check for keyboard entry            *)
  278. (*----------------------------------------------------------------------*)
  279.  
  280. PROCEDURE Check_Keyboard;
  281.  
  282. VAR
  283.    Ch: CHAR;
  284.  
  285. BEGIN (* Check_Keyboard *)
  286.  
  287.    IF KeyPressed THEN
  288.       BEGIN
  289.  
  290.          READ( Kbd, Ch );
  291.  
  292.          IF ( Ch = CHR( ESC ) ) THEN
  293.             IF KeyPressed THEN
  294.                BEGIN
  295.                   READ( Kbd , Ch );
  296.                   CASE ORD( Ch ) OF
  297.                      Alt_R:      IF Receiving_File THEN
  298.                                     Halt_Transfer := TRUE;
  299.                      Alt_S:      IF ( NOT Receiving_File ) THEN
  300.                                     Halt_Transfer := TRUE;
  301.                      Shift_Tab:  Flip_Display_Status;
  302.                      ELSE        Handle_Function_Key( Ch );
  303.                   END;
  304.                END
  305.             ELSE
  306.                IF Async_XOff_Received THEN
  307.                   BEGIN
  308.                      Async_XOff_Received := FALSE;
  309.                      IF Do_Status_Line THEN
  310.                         Write_To_Status_Line( '             ', 65 );
  311.                      EXIT;
  312.                   END;
  313.  
  314.          IF Print_Spooling THEN
  315.             Print_Spooled_File;
  316.  
  317.       END;
  318.  
  319. END   (* Check_Keyboard *);
  320.  
  321. (*----------------------------------------------------------------------*)
  322.  
  323. PROCEDURE Send_Masked_Byte( Ch : INTEGER );
  324.  
  325. BEGIN (* Send_Masked_Byte *)
  326.  
  327.    IF ( Ch < 32 ) THEN
  328.       BEGIN
  329.          Async_Send( CHR( DLE ) );
  330.          Async_Send( CHR( Ch + ORD('@') ) );
  331.       END
  332.    ELSE
  333.       Async_Send( CHR( Ch ) );
  334.  
  335. END   (* Send_Masked_Byte *);
  336.  
  337. (*----------------------------------------------------------------------*)
  338.  
  339. PROCEDURE Send_ACK;
  340.  
  341. BEGIN (* Send_ACK *)
  342.  
  343.    Async_Send( CHR( DLE ) );
  344.    Async_Send( CHR( Seq_Num + ORD('0') ) );
  345.  
  346.    Update_B_Display;
  347.  
  348. END   (* Send_ACK *);
  349.  
  350. (*----------------------------------------------------------------------*)
  351.  
  352. PROCEDURE Send_NAK;
  353.  
  354. BEGIN (* Send_NAK *)
  355.  
  356.    Display_Message_With_Number( 'Sending NAK for block ', Total_Blocks );
  357.  
  358.    Async_Send( CHR( NAK ) );
  359.  
  360.    Update_B_Display;
  361.  
  362. END   (* Send_NAK *);
  363.  
  364. (*----------------------------------------------------------------------*)
  365.  
  366. PROCEDURE Send_ENQ;
  367.  
  368. BEGIN (* Send_ENQ *)
  369.  
  370.    Async_Send( CHR( ENQ ) );
  371.  
  372. END   (* Send_ENQ *);
  373.  
  374. (*----------------------------------------------------------------------*)
  375.  
  376. FUNCTION Read_Byte : BOOLEAN;
  377.  
  378. VAR
  379.    I: INTEGER;
  380.  
  381. BEGIN (* Read_Byte *)
  382.  
  383.    I         := 0;
  384.  
  385.    REPEAT
  386.       I := I + 1;
  387.       Async_Receive_With_Timeout( 1 , Ch );
  388.       Check_Keyboard;
  389.    UNTIL ( I > Timer ) OR ( Ch <> TimeOut ) OR Halt_Transfer;
  390.  
  391.    Read_Byte := ( Ch <> TimeOut ) AND
  392.                 ( I  <= Timer   ) AND
  393.                 ( NOT Halt_Transfer );
  394.  
  395. END   (* Read_Byte *);
  396.  
  397. (*----------------------------------------------------------------------*)
  398.  
  399. FUNCTION Read_Masked_Byte : BOOLEAN;
  400.  
  401. BEGIN (* Read_Masked_Byte *)
  402.  
  403.    Masked := FALSE;
  404.  
  405.    IF  NOT Read_Byte THEN
  406.       BEGIN
  407.          Read_Masked_Byte := FALSE;
  408.          EXIT;
  409.       END;
  410.  
  411.    IF ( Ch = DLE ) THEN
  412.      BEGIN
  413.  
  414.          IF NOT Read_Byte THEN
  415.             BEGIN
  416.                Read_Masked_Byte := FALSE;
  417.                EXIT;
  418.             END;
  419.  
  420.          Ch := Ch AND $1F;
  421.  
  422.          Masked := TRUE;
  423.  
  424.       END;
  425.  
  426.    Read_Masked_Byte := TRUE;
  427.  
  428. END   (* Read_Masked_Byte *);
  429.  
  430. (*----------------------------------------------------------------------*)
  431.  
  432. PROCEDURE Do_CheckSum( Ch : INTEGER );
  433.  
  434. BEGIN (* Do_CheckSum *)
  435.  
  436.    CheckSum := CheckSum SHL 1;
  437.  
  438.    IF ( CheckSum > 255 ) THEN
  439.       CheckSum := ( CheckSum AND $FF ) + 1;
  440.  
  441.    CheckSum := CheckSum + Ch;
  442.  
  443.    IF ( CheckSum > 255 ) THEN
  444.       CheckSum := ( CheckSum AND $FF ) + 1;
  445.  
  446. END   (* Do_CheckSum *);
  447.  
  448. (*----------------------------------------------------------------------*)
  449.  
  450. FUNCTION Send_Packet( size: INTEGER ) : BOOLEAN;
  451.  
  452. VAR
  453.    Action     : INTEGER;
  454.    Errors     : INTEGER;
  455.    Next_Seq   : INTEGER;
  456.    Block_Num  : INTEGER;
  457.    i          : INTEGER;
  458.    Sent_ENQ   : BOOLEAN;
  459.    Quit_Send  : BOOLEAN;
  460.  
  461. BEGIN (* Send_Packet *)
  462.  
  463.    Send_Packet   := FALSE;
  464.    Quit_Send     := FALSE;
  465.  
  466.    Next_Seq      := ( Seq_Num + 1 ) MOD 10;
  467.  
  468.    Total_Packets := Total_Packets + 1;
  469.  
  470.    Errors        := 0;
  471.  
  472.    Sent_ENQ      := FALSE;
  473.  
  474.    Action        := S_Send_Packet;
  475.  
  476.    WHILE ( NOT ( Quit_Send OR Halt_Transfer ) ) DO
  477.       BEGIN
  478.  
  479.          Check_KeyBoard;
  480.  
  481.          CASE Action OF
  482.             S_Send_Packet:  BEGIN
  483.  
  484.                                CheckSum := 0;
  485.  
  486.                                Async_Send( CHR( DLE ) );
  487.                                Async_Send( 'B' );
  488.                                Async_Send( CHR( Next_Seq + ORD('0') ) );
  489.  
  490.                                Do_Checksum( Next_Seq + ORD('0') );
  491.  
  492.                                FOR i := 0 TO Size DO
  493.                                   BEGIN
  494.                                      Send_Masked_Byte( S_Buffer[i] );
  495.                                      Do_Checksum     ( S_Buffer[i] );
  496.                                   END;
  497.  
  498.                                Async_Send( CHR( ETX ) );
  499.  
  500.                                Do_Checksum( ETX );
  501.  
  502.                                Send_Masked_Byte( CheckSum );
  503.  
  504.                                Action := S_Get_DLE;
  505.  
  506.                             END;
  507.  
  508.            S_Get_DLE:       BEGIN
  509.  
  510.                                Timer := 30;
  511.  
  512.                                IF NOT Read_Byte THEN
  513.                                   Action := S_Timed_Out
  514.                                ELSE IF ( Ch = DLE ) THEN
  515.                                   Action := S_Get_num
  516.                                ELSE IF ( Ch = NAK ) THEN
  517.                                   BEGIN
  518.                                      Errors       := Errors + 1;
  519.                                      Total_Errors := Total_Errors + 1;
  520.                                      IF ( Errors > Max_Errors ) THEN
  521.                                         BEGIN
  522.                                            Send_Packet := FALSE;
  523.                                            Quit_Send   := TRUE;
  524.                                         END
  525.                                      ELSE
  526.                                         Action := S_Send_Packet;
  527.                                   END
  528.                                ELSE IF ( Ch = ETX ) THEN
  529.                                   Action := S_Send_NAK;
  530.  
  531.                             END;
  532.  
  533.            S_Get_num:       BEGIN
  534.  
  535.                                Timer := 30;
  536.  
  537.                                IF NOT Read_Byte THEN
  538.                                   Action := S_Timed_Out
  539.                                ELSE IF ( Ch >= ORD('0') ) AND ( Ch <= ORD('9') ) THEN
  540.                                   BEGIN
  541.  
  542.                                      IF ( ( Ch - ORD('0') ) = Seq_Num ) THEN
  543.                                         IF Sent_ENQ THEN
  544.                                            Action := S_Send_Packet
  545.                                         ELSE Action := S_Get_DLE
  546.                                      ELSE
  547.                                         IF ( ( Ch - ORD('0') ) = Next_Seq ) THEN
  548.                                            BEGIN
  549.                                               Seq_Num     := Next_Seq;
  550.                                               Send_Packet := TRUE;
  551.                                               Quit_Send   := TRUE;
  552.                                            END
  553.                                         ELSE
  554.                                            IF ( Errors = 0 ) THEN
  555.                                               Action := S_Send_Packet
  556.                                            ELSE
  557.                                               Action := S_Get_DLE;
  558.  
  559.                                   END
  560.                                ELSE IF ( Ch = nak ) THEN
  561.                                   Action := S_Send_Packet
  562.                                ELSE IF ( Ch = wack ) THEN
  563.                                   BEGIN
  564.                                      Timer  := Timer + 10;
  565.                                      Action := S_Get_DLE;
  566.                                   END
  567.                                ELSE IF ( Ch = ORD('B') ) THEN
  568.                                   Action := S_Get_seq
  569.                                ELSE IF ( Ch = etx ) THEN
  570.                                   Action := S_Send_NAK
  571.                                ELSE
  572.                                   Action := S_Get_DLE;
  573.  
  574.                             END;
  575.  
  576.            S_Get_seq:       BEGIN
  577.  
  578.                                Timer := 10;
  579.  
  580.                                IF NOT Read_Byte THEN
  581.                                   Action := S_Send_NAK
  582.                                ELSE
  583.                                   BEGIN
  584.  
  585.                                      CheckSum  := 0;
  586.  
  587.                                      Block_Num := Ch - ORD('0');
  588.  
  589.                                      Do_Checksum( Ch );
  590.  
  591.                                      i := 0;
  592.  
  593.                                      Action := S_Get_data;
  594.  
  595.                                   END;
  596.  
  597.                             END;
  598.  
  599.            S_Get_data:      BEGIN
  600.  
  601.                                Timer := 10;
  602.  
  603.                                IF NOT Read_Masked_Byte THEN
  604.                                   Action := S_Send_NAK
  605.                                ELSE IF ( ( Ch = etx ) AND ( NOT Masked ) ) THEN
  606.                                   BEGIN
  607.                                      Do_Checksum( ETX );
  608.                                      Action := S_Get_CheckSum;
  609.                                   END
  610.                                ELSE
  611.                                   BEGIN
  612.                                      R_Buffer[i] := Ch;
  613.                                      i           := i + 1;
  614.                                      Do_Checksum( Ch );
  615.                                   END;
  616.  
  617.                             END;
  618.  
  619.            S_Get_CheckSum:  BEGIN
  620.  
  621.                                Timer := 10;
  622.  
  623.                                IF ( NOT Read_Masked_Byte ) THEN
  624.                                   Action := S_Send_NAK
  625.                                ELSE IF ( Ch <> CheckSum ) THEN
  626.                                   Action := S_Send_NAK
  627.                                ELSE IF ( Block_Num <>
  628.                                          ( ( Next_Seq + 1 ) mod 10 ) ) THEN
  629.                                   Action := S_Send_NAK
  630.                                ELSE
  631.                                   BEGIN
  632.                                      Seq_Num     := Block_Num;
  633.                                      Send_ACK;
  634.                                      R_Size      := i;
  635.                                      Send_Packet := TRUE;
  636.                                      Quit_Send   := TRUE;
  637.                                   END;
  638.  
  639.                             END;
  640.  
  641.            S_Timed_Out:     BEGIN
  642.  
  643.                                Errors       := Errors + 1;
  644.                                Total_Errors := Total_Errors + 1;
  645.  
  646.                                IF ( Errors > 4 ) THEN
  647.                                   BEGIN
  648.                                      Send_Packet := FALSE;
  649.                                      Quit_Send   := TRUE;
  650.                                   END;
  651.  
  652.                                Action := S_Get_DLE;
  653.  
  654.                             END;
  655.  
  656.            S_Send_NAK:      BEGIN
  657.  
  658.                                Errors       := Errors + 1;
  659.                                Total_Errors := Total_Errors + 1;
  660.  
  661.                                IF ( Errors > Max_Errors ) THEN
  662.                                   BEGIN
  663.                                      Send_Packet := FALSE;
  664.                                      Quit_Send   := TRUE;
  665.                                   END;
  666.  
  667.                                Send_NAK;
  668.  
  669.                                Action := S_Get_DLE;
  670.  
  671.                             END;
  672.  
  673.          END (* CASE *);
  674.  
  675.          Update_B_Display;
  676.  
  677.       END (* BEGIN *);
  678.  
  679. END    (* Send_Packet *);
  680.  
  681. (*----------------------------------------------------------------------*)
  682.  
  683. PROCEDURE Send_Failure( Code : CHAR );
  684.  
  685. VAR
  686.    Dummy : BOOLEAN;
  687.  
  688. BEGIN (* Send_Failure *)
  689.  
  690.    S_Buffer[0] := ORD( 'F'  );
  691.    S_Buffer[1] := ORD( Code );
  692.  
  693.    Dummy := Send_Packet( 2 );
  694.  
  695. END   (* Send_Failure *);
  696.  
  697. (*----------------------------------------------------------------------*)
  698.  
  699. FUNCTION Read_File( VAR Data_File : INTEGER;
  700.                     VAR S_Buffer  : BufferType;
  701.                     n             : INTEGER;
  702.                     Xmt_Size      : INTEGER ) : INTEGER;
  703.  
  704. VAR
  705.    I : INTEGER;
  706.    L : INTEGER;
  707.  
  708. BEGIN (* Read_File *)
  709.  
  710.    L := Xmt_Size;
  711.  
  712.    I := Read_File_Handle( Data_File, S_Buffer[n], L );
  713.  
  714.    Read_File := L;
  715.  
  716. END    (* Read_File *);
  717.  
  718. (*----------------------------------------------------------------------*)
  719.  
  720. FUNCTION Send_File( Name : AnyStr ) : BOOLEAN;
  721.  
  722. VAR
  723.    N         : INTEGER;
  724.    Data_File : INTEGER;
  725.    IO_Error  : INTEGER;
  726.    F         : FILE OF BYTE;
  727.    Cps_S     : STRING[10];
  728.    CPS       : INTEGER;
  729.    Send_Mess : AnyStr;
  730.  
  731. LABEL Error;
  732.  
  733. BEGIN (* Send_File *)
  734.                                    (* Assume send fails        *)
  735.    Send_File := FALSE;
  736.                                    (* Open file to be uploaded *)
  737.  
  738.       (*$I-*)
  739.    ASSIGN( F , Name );
  740.    RESET ( F );
  741.       (*$I+*)
  742.  
  743.    IF ( Int24Result <> 0 ) THEN
  744.       BEGIN
  745.          Send_Failure('E');
  746.          Display_Message('Can''t open file to be sent, transfer stopped.');
  747.          GOTO Error;
  748.       END;
  749.  
  750.    TFile_Size := LongFileSize( F );
  751.  
  752.       (*$I-*)
  753.    CLOSE( F );
  754.       (*$I+*)
  755.  
  756.    N := Int24Result;
  757.  
  758.    IO_Error := Open_File_Handle( Name , Access_Read_Mode , Data_File );
  759.  
  760.                                    (* If file can't be opened, halt *)
  761.                                    (* transfer.                     *)
  762.  
  763.    IF ( IO_Error <> 0 ) OR ( N <> 0 ) THEN
  764.       BEGIN
  765.          Send_Failure('E');
  766.          Display_Message('Can''t open file to be sent, transfer stopped.');
  767.          GOTO Error;
  768.       END;
  769.                                    (* Remember starting time for transfer *)
  770.    Starting_Time := TimeOfDay;
  771.  
  772.    REPEAT
  773.                                    (* Read next sector of data *)
  774.       S_Buffer[0] := ORD('N');
  775.       N           := Read_File( Data_File, S_Buffer, 1, Xmt_Size );
  776.  
  777.                                    (* Send data packet if anything *)
  778.                                    (* to send.                     *)
  779.       IF ( N > 0 ) THEN
  780.          BEGIN
  781.                                    (* If packet not sent, report *)
  782.                                    (* failure.                   *)
  783.  
  784.             Total_Blocks := Total_Blocks + 1;
  785.             Total_Bytes  := Total_Bytes  + N;
  786.  
  787.             IF ( NOT Send_Packet( n ) ) THEN
  788.                BEGIN
  789.                   Display_Message('Can''t send packet, transfer stopped.');
  790.                   Halt_Transfer := TRUE;
  791.                END;
  792.  
  793.          END;
  794.                                    (* Check for keyboard input halting *)
  795.                                    (* transfer.                        *)
  796.  
  797.       Check_Keyboard;
  798.  
  799.       IF Halt_Transfer THEN
  800.          BEGIN
  801.             Send_Failure('E');
  802.             Display_Message('ESC key hit -- transfer terminated.');
  803.          END;
  804.  
  805.       Update_B_Display;
  806.  
  807.    UNTIL ( N <= 0 ) OR Halt_Transfer;
  808.  
  809.                                    (* Close file *)
  810.    Ending_Time := TimeOfDay;
  811.    IO_Error    := Close_File_Handle( Data_File );
  812.  
  813.    IF ( NOT Halt_Transfer ) THEN
  814.       BEGIN
  815.                                    (* Send end of file packet. *)
  816.          S_Buffer[0] := ORD('T');
  817.          S_Buffer[1] := ORD('C');
  818.  
  819.          IF ( NOT Send_Packet( 2 ) ) THEN
  820.             Display_Message('Can''t send end of file packet, transfer stopped.')
  821.          ELSE
  822.             BEGIN
  823.                Send_File  := TRUE;
  824.                Total_Time := TimeDiff( Starting_Time , Ending_Time );
  825.                Send_Mess  := 'Send complete.';
  826.                IF ( Total_Time > 0 ) THEN
  827.                   BEGIN
  828.                      CPS := TRUNC( Total_Bytes / Total_Time );
  829.                      STR( CPS , Cps_S );
  830.                      Send_Mess := Send_Mess + ' Transfer rate: ' + Cps_S +
  831.                                   ' CPS.';
  832.                   END;
  833.                Display_Message( Send_Mess );
  834.             END;
  835.  
  836.       END;
  837.  
  838. Error:
  839.    IF Reset_Port THEN
  840.       Async_Reset_Port( Comm_Port, Baud_Rate,
  841.                         Xmodem_Parity_Save,
  842.                         Xmodem_Bits_Save,
  843.                         Xmodem_Stop_Save );
  844.    Reset_Port := FALSE;
  845.  
  846.    DELAY( Two_Second_Delay );
  847.  
  848. END    (* Send_File *);
  849.  
  850. (*----------------------------------------------------------------------*)
  851.  
  852. FUNCTION Read_Packet : BOOLEAN;
  853.  
  854. (* True if packet is available from host *)
  855.  
  856. VAR
  857.    Action     : INTEGER;
  858.    Next_Seq   : INTEGER;
  859.    Block_Num  : INTEGER;
  860.    Errors     : INTEGER;
  861.    i          : INTEGER;
  862.  
  863. BEGIN (* Read_Packet *)
  864.  
  865.                                    (* Clear out packet area *)
  866.    FillChar( R_Buffer , 520 , 0 );
  867.  
  868.                                    (* Packet sequence number *)
  869.  
  870.    Next_Seq      := ( Seq_Num + 1 ) MOD 10;
  871.  
  872.    Errors        := 0;
  873.    Action        := R_Get_DLE;
  874.    Total_Packets := Total_Packets + 1;
  875.  
  876.                                    (* Get next packet *)
  877.    WHILE ( NOT Halt_Transfer ) DO
  878.       BEGIN
  879.  
  880.          Check_KeyBoard;
  881.  
  882.          Timer := 10;
  883.  
  884.          CASE Action OF
  885.  
  886.             R_Get_DLE: BEGIN
  887.  
  888.                           IF ( NOT Read_Byte ) THEN
  889.                              Action := R_Send_NAK
  890.                           ELSE IF ( ( Ch AND $7F ) = dle ) THEN
  891.                              Action := R_Get_b
  892.                           ELSE IF ( ( Ch AND $7F ) = ENQ ) THEN
  893.                              Action := R_Send_ACK;
  894.                        END;
  895.  
  896.             R_Get_b:   BEGIN
  897.  
  898.                           IF ( NOT Read_Byte ) THEN
  899.                              Action := R_Send_NAK
  900.                           ELSE IF ( ( Ch AND $7F ) = ORD('B') ) THEN
  901.                              Action := R_Get_seq
  902.                           ELSE IF ( Ch = ENQ ) THEN
  903.                              Action := R_Send_ACK
  904.                           ELSE
  905.                              Action := R_Get_DLE;
  906.                        END;
  907.  
  908.             R_Get_seq: BEGIN
  909.  
  910.                           IF ( NOT Read_Byte ) THEN
  911.                              Action := R_Send_NAK
  912.                           ELSE IF ( Ch = ENQ ) THEN
  913.                              Action := R_Send_ACK
  914.                           ELSE
  915.                              BEGIN
  916.                                 CheckSum  := 0;
  917.                                 Block_Num := Ch - ORD('0');
  918.                                 Do_Checksum( Ch );
  919.                                 i      := 0;
  920.                                 Action := R_Get_data;
  921.                              END;
  922.  
  923.                        END;
  924.  
  925.            R_Get_data: BEGIN
  926.  
  927.                           IF ( NOT Read_Masked_Byte ) THEN
  928.                              Action := R_Send_NAK
  929.                           ELSE IF ( ( Ch = etx ) AND ( NOT Masked ) ) THEN
  930.                              BEGIN
  931.                                 Do_Checksum( etx );
  932.                                 Action := R_Get_CheckSum;
  933.                              END
  934.                           ELSE
  935.                              BEGIN
  936.                                 R_Buffer[i] := Ch;
  937.                                 i           := i + 1;
  938.                                 Do_Checksum( Ch );
  939.                              END;
  940.  
  941.                        END;
  942.  
  943.        R_Get_CheckSum: BEGIN
  944.  
  945.                           IF ( NOT Read_Masked_Byte ) THEN
  946.                              Action := R_Send_NAK
  947.                           ELSE IF ( Ch <> CheckSum ) THEN
  948.                              Action := R_Send_NAK
  949.                           ELSE IF ( Block_Num = Seq_Num ) THEN
  950.                              BEGIN
  951.                                 IF ( R_Buffer[0] = ORD('F') ) THEN
  952.                                    BEGIN
  953.                                       Seq_Num     := Block_Num;
  954.                                       R_Size      := i;
  955.                                       Read_Packet :=  TRUE;
  956.                                       EXIT;
  957.                                    END
  958.                                 ELSE
  959.                                    Action := R_Send_ACK;
  960.                              END
  961.                           ELSE IF ( Block_Num <> Next_Seq ) THEN
  962.                              Action := R_Send_NAK
  963.                           ELSE
  964.                              BEGIN
  965.                                 Seq_Num     := Block_Num;
  966.                                 R_Size      := i;
  967.                                 Read_Packet := TRUE;
  968.                                 EXIT;
  969.                              END;
  970.  
  971.                        END;
  972.  
  973.            R_Send_NAK: BEGIN
  974.  
  975.                           Errors       := Errors + 1;
  976.                           Total_Errors := Total_Errors + 1;
  977.  
  978.                           IF ( Errors > Max_Errors ) THEN
  979.                              BEGIN
  980.                                 Read_Packet := FALSE;
  981.                                 EXIT;
  982.                              end;
  983.  
  984.                           Send_NAK;
  985.  
  986.                           Action := R_Get_DLE;
  987.  
  988.                        END;
  989.  
  990.            R_Send_ACK: BEGIN
  991.                                    (* wait for the next block *)
  992.  
  993.                           Send_ACK;
  994.                           Action := R_Get_DLE;
  995.  
  996.                        END;
  997.  
  998.           END (* CASE *);
  999.  
  1000.    END (* WHILE *);
  1001.  
  1002. END    (* Read_Packet *);
  1003.  
  1004. (*----------------------------------------------------------------------*)
  1005.  
  1006. FUNCTION Write_File( VAR Data_File : INTEGER;
  1007.                          R_Buffer  : BufferType;
  1008.                          n         : INTEGER;
  1009.                          size      : INTEGER) : INTEGER;
  1010.  
  1011. BEGIN (* Write_File *)
  1012.  
  1013.    Write_File := Write_File_Handle( Data_File, R_Buffer[ n ], size );
  1014.  
  1015. END   (* Write_File *);
  1016.  
  1017. (*----------------------------------------------------------------------*)
  1018.  
  1019. FUNCTION Receive_File( Name : AnyStr ) : BOOLEAN;
  1020.  
  1021. VAR
  1022.    Data_File : INTEGER;
  1023.    Status    : INTEGER;
  1024.    R_File    : BOOLEAN;
  1025.    Cps_S     : STRING[10];
  1026.    CPS       : INTEGER;
  1027.    Rec_Mess  : AnyStr;
  1028.  
  1029. LABEL  Error;
  1030.  
  1031. BEGIN (* Receive_File *)
  1032.                                    (* Assume transfer fails   *)
  1033.    R_File := FALSE;
  1034.                                    (* Open file to be created *)
  1035.    IF ( POS( ':' , Name ) = 0 ) AND
  1036.       ( POS( '\' , Name ) = 0 ) THEN
  1037.       Name := Download_Dir_Path + Name;
  1038.  
  1039.    Status := Create_File_Handle( Name, Attribute_None, Data_File );
  1040.  
  1041.                                    (* Halt transfer if file can't be *)
  1042.                                    (* opened.                        *)
  1043.    IF ( Status <> 0 ) THEN
  1044.       BEGIN
  1045.          Send_Failure('E');
  1046.          Display_Message('Can''t open output file, transfer stoppped.');
  1047.          Receive_File := FALSE;
  1048.          GOTO Error;
  1049.       END;
  1050.                                    (* Send ACK to start transfer  *)
  1051.    Send_ACK;
  1052.                                    (* Remember starting time for transfer *)
  1053.    Starting_Time := TimeOfDay;
  1054.                                    (* Begin loop over packets *)
  1055.  
  1056.    WHILE ( NOT ( Halt_Transfer OR R_File  ) ) DO
  1057.       BEGIN
  1058.                                    (* Get next packet *)
  1059.          IF Read_Packet THEN
  1060.             BEGIN
  1061.                                    (* Select Action based upon packet type *)
  1062.  
  1063.                CASE CHR( R_Buffer[0] ) OF
  1064.  
  1065.                                    (* Data for file -- write it and *)
  1066.                                    (* acknowledge it.               *)
  1067.                   'N': BEGIN
  1068.                           Status := Write_File( Data_File, R_Buffer, 1,
  1069.                                                 R_Size - 1 );
  1070.                           Send_ACK;
  1071.                           Total_Blocks := Total_Blocks + 1;
  1072.                           Total_Bytes  := Total_Bytes  + R_Size - 1;
  1073.                        END;
  1074.                                    (* End of transfer -- close file *)
  1075.                                    (* and acknowledge end of file   *)
  1076.                   'T': BEGIN
  1077.  
  1078.                           IF ( R_Buffer[1] = ORD('C') ) THEN
  1079.                              BEGIN
  1080.                                 Ending_Time  := TimeOfDay;
  1081.                                 Status := Close_File_Handle( Data_File );
  1082.                                 Send_ACK;
  1083.                                 R_File  := TRUE;
  1084.                                 Total_Time := TimeDiff( Starting_Time ,
  1085.                                                         Ending_Time );
  1086.                                 Rec_Mess   := 'Receive complete.';
  1087.                                 IF ( Total_Time > 0 ) THEN
  1088.                                    BEGIN
  1089.                                       CPS := TRUNC( Total_Bytes / Total_Time );
  1090.                                       STR( CPS , Cps_S );
  1091.                                       Rec_Mess := Rec_Mess + ' Transfer rate: ' + Cps_S +
  1092.                                                   ' CPS.';
  1093.                                    END;
  1094.  
  1095.                                 Display_Message( Rec_Mess );
  1096.  
  1097.                              END;
  1098.  
  1099.                        END;
  1100.                                    (* Stop transfer received -- halt *)
  1101.                                    (* transfer and acknowledge.      *)
  1102.                   'F': BEGIN
  1103.                           Send_ACK;
  1104.                           Halt_Transfer := TRUE;
  1105.                           Display_Message('Host cancelled transfer.');
  1106.                        END;
  1107.  
  1108.                 END   (* CASE *);
  1109.  
  1110.             END  (* IF *);
  1111.                                    (* Check for keyboard input halting *)
  1112.                                    (* transfer.                        *)
  1113.          Check_Keyboard;
  1114.  
  1115.          IF Halt_Transfer THEN
  1116.             BEGIN
  1117.                Send_Failure('E');
  1118.                Display_Message('ESC key hit -- transfer terminated.');
  1119.                ClrEol;
  1120.             END;
  1121.  
  1122.       END  (* WHILE *);
  1123.  
  1124.    Receive_File := R_File;
  1125.    Ending_Time  := TimeOfDay;
  1126.    Status       := Close_File_Handle( Data_File );
  1127.  
  1128. Error:
  1129.    IF Reset_Port THEN
  1130.       Async_Reset_Port( Comm_Port, Baud_Rate,
  1131.                         Xmodem_Parity_Save,
  1132.                         Xmodem_Bits_Save,
  1133.                         Xmodem_Stop_Save );
  1134.    Reset_Port := FALSE;
  1135.  
  1136.    DELAY ( Two_Second_Delay );
  1137.  
  1138. END   (* Receive_File *);
  1139.  
  1140. (*--------------- CompuServe_B_Transfer --- main code -------------------*)
  1141.  
  1142. BEGIN (* CompuServe_B_Transfer *)
  1143.  
  1144.                                    (* Reset comm parms to 8,n,1 *)
  1145.    Xmodem_Bits_Save   := Data_Bits;
  1146.    Xmodem_Parity_Save := Parity;
  1147.    Xmodem_Stop_Save   := Stop_Bits;
  1148.  
  1149.    IF ( ( Data_Bits = 8 ) AND ( Parity = 'N' ) ) THEN
  1150.       Reset_Port := FALSE
  1151.    ELSE
  1152.       BEGIN
  1153.          Async_Reset_Port( Comm_Port, Baud_Rate, 'N', 8, 1 );
  1154.          Reset_Port := TRUE;
  1155.       END;
  1156.  
  1157.                                    (* Announce protocol starts *)
  1158.  
  1159.    Save_Partial_Screen( Saved_Screen, 5, 10, 75, 16 );
  1160.  
  1161.    Comp_Title := 'CompuServe B Protocol';
  1162.  
  1163.    Receiving_File := TRUE;
  1164.  
  1165.    Initialize_Transfer_Display;
  1166.                                    (* Assume transfer goes OK *)
  1167.  
  1168.    CompuServe_B_Transfer := TRUE;
  1169.  
  1170.    Halt_Transfer  := FALSE;
  1171.    Xoff_Flag      := FALSE;
  1172.    Receiving_File := TRUE;
  1173.    Display_Status := TRUE;
  1174.    Seq_Num        := 0;
  1175.    Comp_Title     := 'CIS B -- ';
  1176.    Total_Blocks   := 0;
  1177.    Total_Packets  := 0;
  1178.    Total_Errors   := 0;
  1179.    Total_Bytes    := 0.0;
  1180.                                    (* ACKnowledge start of protocol *)
  1181.    Send_ACK;
  1182.                                    (* Read initial packet *)
  1183.    IF Read_Packet THEN
  1184.       BEGIN
  1185.                                    (* Select Action based upon packet type *)
  1186.  
  1187.          CASE CHR( R_Buffer[0] ) OF
  1188.  
  1189.                                    (* Upload or download *)
  1190.             'T': BEGIN
  1191.  
  1192.                     CASE CHR( R_Buffer[1] ) OF
  1193.                        'D' : BEGIN
  1194.                                 Comp_Title := 'Receiving ';
  1195.                                 Receiving_File := TRUE;
  1196.                              END;
  1197.                        'U' : BEGIN
  1198.                                 Comp_Title := 'Sending ';
  1199.                                 Receiving_File := FALSE;
  1200.                              END;
  1201.                        ELSE
  1202.                              BEGIN
  1203.                                 Send_Failure('N');
  1204.                                 CompuServe_B_Transfer := FALSE;
  1205.                                 GOTO Error_Exit;
  1206.                              END;
  1207.                     END  (* CASE *);
  1208.  
  1209.                                    (* Get file name *)
  1210.  
  1211.                     CASE CHR( R_Buffer[2] ) OF
  1212.                        'A': Comp_Title := Comp_Title + 'ASCII file "';
  1213.                        'B': Comp_Title := Comp_Title + 'Binary file "';
  1214.                        ELSE
  1215.                           BEGIN
  1216.                              Send_Failure('N');        (* Not implemented *)
  1217.                              CompuServe_B_Transfer := FALSE;
  1218.                              GOTO Error_Exit;
  1219.                           END;
  1220.                     END   (* CASE *);
  1221.  
  1222.                     I        := 2;
  1223.                     FileName := '';
  1224.  
  1225.                     WHILE ( R_Buffer[I] <> 0 ) AND ( I < R_Size ) DO
  1226.                        BEGIN
  1227.                           I        := I + 1;
  1228.                           FileName := FileName + CHR( R_Buffer[I] );
  1229.                        END;
  1230.  
  1231.                     Comp_Title := Comp_Title + FileName + '"';
  1232.  
  1233.                                    (* Display file transfer header *)
  1234.  
  1235.                     Initialize_Transfer_Display;
  1236.  
  1237.                                    (* Perform transfer *)
  1238.  
  1239.                     IF ( R_Buffer[1] = ORD('U') ) THEN
  1240.                        Dummy := Send_File( FileName )
  1241.                     ELSE
  1242.                        Dummy := Receive_File( FileName );
  1243.  
  1244.                  END;
  1245.  
  1246.          END (* CASE *);
  1247.  
  1248.       END (* IF *)
  1249.                                    (* No initial packet -- quit *)
  1250.     ELSE
  1251.        BEGIN
  1252.           Display_Message('Cannot receive initial packet, transfer cancelled');
  1253.           IF Reset_Port THEN
  1254.              Async_Reset_Port( Comm_Port, Baud_Rate, Xmodem_Parity_Save,
  1255.                                Xmodem_Bits_Save, Xmodem_Stop_Save );
  1256.           Reset_Port := FALSE;
  1257.           DELAY( Two_Second_Delay );
  1258.        END;
  1259.  
  1260. Error_Exit:
  1261.                                    (* Reset comm parms back *)
  1262.    IF Reset_Port THEN
  1263.       Async_Reset_Port( Comm_Port, Baud_Rate, Xmodem_Parity_Save,
  1264.                         Xmodem_Bits_Save, Xmodem_Stop_Save );
  1265.  
  1266.                                    (* Restore previous screen *)
  1267.    Restore_Screen( Saved_Screen );
  1268.    Reset_Global_Colors;
  1269.                                    (* Restore cursor *)
  1270.    CursorOn;
  1271.  
  1272. END   (* CompuServe_B_Transfer *);
  1273.